home *** CD-ROM | disk | FTP | other *** search
/ Aminet 25 / Aminet 25 (1998)(GTI - Schatztruhe)[!][Jun 1998].iso / Aminet / util / pack / xpk_Source.lha / xpk_Source / Oberon / rlen / xpkRLen.mod next >
Text File  |  1998-02-08  |  5KB  |  189 lines
  1. (*************************************************************************
  2.  
  3. :Program.    xpkRLen.mod
  4. :Contents.   demo XpkSub library
  5. :Author.     Hartmut Goebel [hG]
  6. :Language.   Oberon
  7. :Translator. Amiga Oberon V2.13
  8. :History.    V0.9, 11 Jan 1992 Hartmut Goebel [hG]
  9. :History.    V1.0, 27 Jul 1992 [hG] working but not really tested!
  10. :Date.       27 Jul 1992 12:30:14
  11.  
  12. *************************************************************************)
  13.  
  14. (*
  15.  * IMPORTANT:
  16.  * The packing algorithm of this Lib has not been tested to be proof!
  17.  *
  18.  * It is only a demo to show how to make XPK-Libs with AmigaOberon
  19.  * Just compile this using SMALLCODE, SMALLDATA and link it by
  20.  * 'LibLink with xpkRLen.wth'. Done.
  21.  *)
  22.  
  23. MODULE xpkRLen;
  24.  
  25. IMPORT
  26.   s  := SYSTEM,
  27.   xpk:= XpkMaster,
  28.   xs := XpkSubDefs;
  29.  
  30. CONST
  31.   RLEN = s.VAL(LONGINT,"RLEN");
  32.  
  33.   RlenMode = xpk.XpkMode(
  34.     NIL,       (* next                *)
  35.     100,       (* upto                *)
  36.     LONGSET{xpk.mfA3000Speed},(* flags    *)
  37.     0,         (* packmem             *)
  38.     0,         (* unpackmem           *)
  39.     140,       (* packspeed,   K/sec  *)
  40.     1043,      (* unpackspeed, K/sec  *)
  41.     45,        (* ratio,      *0.1%   *)
  42.     0,         (* reserved            *)
  43.     "normal"); (* description         *)
  44.  
  45.   RlenInfo = xs.XpkInfo(
  46.     1,               (* info version *)
  47.     0,               (* lib  version *)
  48.     0,               (* master vers  *)
  49.     0,               (* pad          *)
  50.     s.ADR("RLEN"),                  (* short name   *)
  51.     s.ADR("Run Length 1.0"),        (* long name    *)
  52.     s.ADR("Fast and simple compression usable for simple data"), (* description*)
  53.     RLEN,                           (* 4 letter ID  *)
  54.     LONGSET{xs.pkChunk,xs.upChunk}, (* flags        *)
  55.     32000,           (* max in chunk *)
  56.     0,               (* min in chunk *)
  57.     32000,           (* def in chunk *)
  58.     NIL,             (* pk message   *)
  59.     NIL,             (* up message   *)
  60.     NIL,             (* pk past msg  *)
  61.     NIL,             (* up past msg  *)
  62.     50,              (* def mode     *)
  63.     0,               (* pad          *)
  64.     s.ADR(RlenMode), (* modes        *)
  65.     0,0,0,0,0,0);    (* reserved     *)
  66.  
  67. TYPE
  68.   BufferPtr = POINTER TO ARRAY MAX(LONGINT)-1 OF BYTE;
  69.  
  70. (*
  71.  * Returns an info structure about our packer
  72.  *)
  73. PROCEDURE XpksPackerInfo * (): xs.XpkInfoPtr;
  74. (* No need for SaveRegs here, cause only d0 will be used! *)
  75. BEGIN
  76.   RETURN s.ADR(RlenInfo);
  77. END XpksPackerInfo;
  78.  
  79.  
  80. PROCEDURE XpksPackFree * (params{8}: xs.XpkSubParamsPtr);
  81. BEGIN
  82. END XpksPackFree;
  83.  
  84. (*
  85.  * This forces the next chunk to be uncompressable independent from the
  86.  * previous one. This is always the case in RLEN.
  87.  *)
  88. PROCEDURE XpksPackReset * (params{8}: xs.XpkSubParamsPtr): LONGINT;
  89. (* No need for SaveRegs here, cause only d0 will be used! *)
  90. BEGIN
  91.   RETURN 0;
  92. END XpksPackReset;
  93.  
  94.  
  95. PROCEDURE XpksUnpackFree * (params{8}: xs.XpkSubParamsPtr);
  96. BEGIN
  97. END XpksUnpackFree;
  98.  
  99.  
  100. (*
  101.  * Pack a chunk
  102.  *)
  103. PROCEDURE XpksPackChunk * (xpar{8}: xs.XpkSubParamsPtr): LONGINT;
  104. (* $SaveRegs+ *)
  105. VAR
  106.   get, put: BufferPtr;
  107.   i: INTEGER;
  108.   in, out, start, end: LONGINT;
  109.   run: BOOLEAN; v: CHAR;
  110. BEGIN
  111.   get := xpar.inBuf;
  112.   put := xpar.outBuf;
  113.   end  := xpar.inLen;
  114.   in := 0; out := 0; start := 0;
  115.   LOOP
  116.     run := (get[0]=get[1]) & (get[0]=get[2]);
  117.  
  118.     IF in+out+4 > xpar.outBufLen THEN
  119.       RETURN xpk.errExpansion; END;
  120.  
  121.     IF run OR (in-start=127) OR (in=end) THEN (* write uncompressed *)
  122.       IF in-start # 0 THEN
  123.         put[out] := CHR(in-start); INC(out);
  124.         i := SHORT(in-start);
  125.         REPEAT
  126.           put[out] := get[start]; INC(out); INC(start);
  127.           DEC(i);
  128.         UNTIL i = 0;
  129.       END;
  130.       IF in = end THEN
  131.         put[out] := CHR(0); INC(out);
  132.         EXIT;
  133.       END;
  134.       start := in;
  135.     END;
  136.  
  137.     IF run THEN                                (* write compressed   *)
  138.       v := get[i];
  139.       i := 3;
  140.       WHILE (in+i<end) & (get[in+i]=v) & (i<127) DO
  141.         INC(i); END;
  142.       put[out] := CHR(-i); INC(out);
  143.       put[out] := v; INC(out);
  144.       INC(in,i);
  145.       start := in;
  146.     ELSE
  147.       INC(in);
  148.     END;
  149.   END;
  150.   xpar.outLen := out;
  151.  
  152.   RETURN 0;
  153. END XpksPackChunk;
  154.  
  155.  
  156. PROCEDURE XpksUnpackChunk * (xpar{8}: xs.XpkSubParamsPtr): LONGINT;
  157. (* $SaveRegs+ *)
  158. VAR
  159.   i: INTEGER;
  160.   get, put: BufferPtr;
  161.   in, out: LONGINT;
  162.   v: CHAR;
  163. BEGIN
  164.   get := xpar.inBuf;
  165.   put := xpar.outBuf;
  166.   in := 0; out := 0;
  167.   LOOP
  168.     i := ORD(get[in]);
  169.     IF i = 0 THEN EXIT; END;
  170.     INC(in);
  171.     IF i > 0 THEN
  172.       REPEAT
  173.         put[out]:=get[in]; INC(out); INC(in);
  174.         DEC(i);
  175.       UNTIL i = 0;
  176.     ELSE
  177.       v := get[in]; INC(in);
  178.       REPEAT
  179.         put[out]:=v; INC(out);
  180.         INC(i);
  181.       UNTIL i = 0;
  182.     END;
  183.   END;
  184.   RETURN 0;
  185. END XpksUnpackChunk;
  186.  
  187. END xpkRLen.
  188.  
  189.